home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 24 / CU Amiga Magazine's Super CD-ROM 24 (1998)(EMAP Images)(GB)(Track 1 of 2)[!][issue 1998-07].iso / CUCD / Programming / SWI / source / src / pl-proc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1998-02-18  |  38.4 KB  |  1,609 lines
  1. /*  $Id: pl-proc.c,v 1.55 1998/02/18 13:57:16 jan Exp $
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: Procedure (re) allocation
  8. */
  9.  
  10. /*#define O_DEBUG 1*/
  11. #include "pl-incl.h"
  12.  
  13. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  14. General  handling  of  procedures:  creation;  adding/removing  clauses;
  15. finding source files, etc.
  16. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  17.  
  18. forwards void        resetReferencesModule(Module);
  19. forwards void        resetProcedure(Procedure proc);
  20. forwards SourceFile    indexToSourceFile(int index);
  21.  
  22. SourceFile     sourceFileTable = (SourceFile) NULL;
  23. SourceFile     tailSourceFileTable = (SourceFile) NULL;
  24. static void    removeClausesProcedure(Procedure proc, int sfindex);
  25.  
  26. Procedure
  27. lookupProcedure(functor_t f, Module m)
  28. { Procedure proc;
  29.   register Definition def;
  30.   Symbol s;
  31.   
  32.   if ( (s = lookupHTable(m->procedures, (void *)f)) )
  33.     return (Procedure) s->value;
  34.  
  35.   proc = (Procedure)  allocHeap(sizeof(struct procedure));
  36.   def  = (Definition) allocHeap(sizeof(struct definition));
  37.   proc->type = PROCEDURE_TYPE;
  38.   proc->definition = def;
  39.   def->functor = valueFunctor(f);
  40.   def->module  = m;
  41.   addHTable(m->procedures, (void *)f, proc);
  42.   GD->statistics.predicates++;
  43.  
  44.   def->definition.clauses = NULL;
  45.   def->lastClause = NULL;
  46.   def->hash_info = NULL;
  47. #ifdef O_PROFILE
  48.   def->profile_ticks = 0;
  49.   def->profile_calls = 0;
  50.   def->profile_redos = 0;
  51.   def->profile_fails = 0;
  52. #endif /* O_PROFILE */
  53.   clearFlags(def);
  54.   def->references = 0;
  55.   resetProcedure(proc);
  56.  
  57.   return proc;
  58. }
  59.  
  60.  
  61. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  62. resetProcedure() is called  by  lookupProcedure()   for  new  ones,  and
  63. abolishProcedure() by abolish/2. In the latter   case, abolish may leave
  64. dirty clauses when called on a   running predicate. Hence, NEEDSCLAUSEGC
  65. should be retained. Bug found by Paulo Moura, LogTalk developer.
  66. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  67.  
  68. static void
  69. resetProcedure(Procedure proc)
  70. { register Definition def = proc->definition;
  71.  
  72.   def->flags ^= def->flags & ~(SPY_ME|NEEDSCLAUSEGC);
  73.   set(def, TRACE_ME);
  74.   def->indexCardinality = 0;
  75.   def->number_of_clauses = 0;
  76.   if ( def->functor->arity == 0 )
  77.   { def->indexPattern = 0x0;
  78.   } else
  79.   { def->indexPattern = (0x0 | NEED_REINDEX);
  80.     set(def, AUTOINDEX);
  81.   }
  82.   
  83.   if ( def->hash_info && def->references == 0 )
  84.   { unallocClauseIndexTable(def->hash_info);
  85.     def->hash_info = NULL;
  86.   }
  87. }
  88.  
  89. Procedure
  90. isCurrentProcedure(functor_t f, Module m)
  91. { Symbol s;
  92.  
  93.   if ( (s = lookupHTable(m->procedures, (void *)f)) )
  94.     return (Procedure) s->value;
  95.  
  96.   return NULL;
  97. }
  98.  
  99. bool
  100. isDefinedProcedure(Procedure proc)
  101. { Definition def = proc->definition;
  102.  
  103.   if ( true(def, DYNAMIC|FOREIGN) )
  104.     succeed;
  105.  
  106.   if ( def->definition.clauses && false(def, FOREIGN) )
  107.   { ClauseRef c;
  108.  
  109.     if ( false(def, NEEDSCLAUSEGC) )
  110.       succeed;
  111.     
  112.     for(c = def->definition.clauses; c; c = c->next)
  113.     { Clause cl = c->clause;
  114.  
  115.       if ( false(cl, ERASED) )
  116.     succeed;
  117.     }
  118.   }
  119.  
  120.   fail;
  121. }
  122.  
  123.  
  124. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  125. Find a procedure for defining it.  Here   we check whether the procedure
  126. to be defined is a system predicate.
  127. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  128.  
  129. Procedure
  130. lookupProcedureToDefine(functor_t def, Module m)
  131. { Procedure proc;
  132.  
  133.   if ( (proc = isCurrentProcedure(def, m)) && false(proc->definition, SYSTEM) )
  134.     return proc;
  135.  
  136.   if ( !SYSTEM_MODE &&
  137.        MODULE_system &&
  138.        (proc=isCurrentProcedure(def, MODULE_system)) &&
  139.        true(proc->definition, LOCKED) &&
  140.        false(proc->definition, DYNAMIC) )
  141.   { warning("Attempt to redefine a system predicate: %s/%d\n"
  142.         "\tUse :- redefine_system_predicate(+Head) if this is intended",
  143.         stringAtom(proc->definition->functor->name),
  144.         proc->definition->functor->arity);
  145.     return NULL;
  146.   }
  147.  
  148.   return lookupProcedure(def, m);
  149. }
  150.  
  151.  
  152. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  153. get_functor() translates term  of  the   format  +Name/+Arity  into  the
  154. internal functor represenation. It fails and  raises an exception on the
  155. various possible format or represenation errors.  ISO compliant.
  156.  
  157. The return value is 1 normally, -1  if no functor exists and GF_EXISTING
  158. is defined, and 0 if an error was raised.
  159. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  160.  
  161. #define GF_EXISTING    1
  162. #define GF_PROCEDURE    2        /* check for max arity */
  163.  
  164. static int
  165. get_functor(term_t descr, functor_t *fdef, Module *m, term_t h, int how)
  166. { term_t head = PL_new_term_ref();
  167.  
  168.   if ( !PL_strip_module(descr, m, head) )
  169.     fail;
  170.  
  171.   if ( PL_is_functor(head, FUNCTOR_divide2) )
  172.   { term_t a = PL_new_term_ref();
  173.     atom_t name;
  174.     int arity;
  175.  
  176.     PL_get_arg(1, head, a);
  177.     if ( PL_get_atom(a, &name) )
  178.     { PL_get_arg(2, head, a);
  179.       if ( PL_get_integer(a, &arity) )
  180.       { if ( arity < 0 )
  181.     { return PL_error(NULL, 0, NULL, ERR_DOMAIN,
  182.               ATOM_not_less_than_zero, a);
  183.     } else if ( (how&GF_PROCEDURE) && arity > MAXARITY )
  184.     { char buf[100];
  185.  
  186.       return PL_error(NULL, 0,
  187.               tostr(buf, "limit is %d, request = %d",
  188.                 MAXARITY, arity),
  189.               ERR_REPRESENTATION, ATOM_max_arity);
  190.     } else
  191.     { *fdef = PL_new_functor(name, arity);
  192.       
  193.       if ( h )
  194.         PL_put_term(h, head);
  195.       
  196.       succeed;
  197.     }
  198.       } else
  199.       { if ( PL_is_variable(a) )
  200.       goto ierror;
  201.  
  202.     return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_integer, a);
  203.       }
  204.     } else
  205.     { if ( PL_is_variable(a) )
  206.     goto ierror;
  207.  
  208.       return PL_error(NULL, 0, NULL, ERR_TYPE, ATOM_atom, a);
  209.     }
  210.   } else if ( PL_get_functor(head, fdef) )
  211.   { if ( h )
  212.       PL_put_term(h, head);
  213.       
  214.     succeed;
  215.   } else
  216.   { if ( PL_is_variable(head) )
  217.     { ierror:
  218.       return PL_error(NULL, 0, NULL, ERR_INSTANTIATION);
  219.     } else
  220.       return PL_error(NULL, 0, NULL, ERR_TYPE,
  221.               ATOM_predicate_indicator, head);
  222.   }
  223. }
  224.  
  225.       
  226. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  227. Get the specified procedure from a   Prolog  argument.  This argument is
  228. either a head or a term of the form module:head.  If `create' is TRUE, a
  229. procedure is created in the module.  Otherwise, the system traverses the
  230. module-inheritance chain to find the existing procedure.
  231. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  232.  
  233. int
  234. get_procedure(term_t descr, Procedure *proc, term_t h, int how)
  235. { Module m = (Module) NULL;
  236.   functor_t fdef;
  237.   Procedure p;
  238.  
  239.   if ( (how&GP_NAMEARITY) )
  240.   { if ( !get_functor(descr, &fdef, &m, h, GF_PROCEDURE) )
  241.       fail;
  242.   } else
  243.   { term_t head = PL_new_term_ref();
  244.     int arity;
  245.  
  246.     if ( !PL_strip_module(descr, &m, head) )
  247.       fail;
  248.  
  249.     if ( h )
  250.       PL_put_term(h, head);
  251.  
  252.     if ( !PL_get_functor(head, &fdef) )
  253.       return warning("Illegal predicate specification");
  254.     if ( (arity=arityFunctor(fdef)) > MAXARITY )
  255.     { char buf[100];
  256.       return PL_error(NULL, 0,
  257.               tostr(buf, "limit is %d, request = %d",
  258.                 MAXARITY, arity),
  259.               ERR_REPRESENTATION, ATOM_max_arity);
  260.     }
  261.   }
  262.   
  263.   switch( how & GP_HOW_MASK )
  264.   { case GP_CREATE:
  265.       *proc = lookupProcedure(fdef, m);
  266.       break;
  267.     case GP_FINDHERE:
  268.       if ( (p = isCurrentProcedure(fdef, m)) )
  269.       { *proc = p;
  270.         break;
  271.       }
  272.       fail;
  273.     case GP_FIND:
  274.       for( ; m; m = m->super )
  275.       { if ( (p = isCurrentProcedure(fdef, m)) )
  276.     { *proc = p;
  277.       goto out;
  278.     }
  279.       }
  280.       fail;
  281.     case GP_DEFINE:
  282.       if ( (p = lookupProcedureToDefine(fdef, m)) )
  283.       { *proc = p;
  284.         break;
  285.       }
  286.       fail;
  287.     case GP_RESOLVE:
  288.       if ( (p = resolveProcedure(fdef, m)) )
  289.       { *proc = p;
  290.         break;
  291.       }
  292.       fail;
  293.     default:
  294.       assert(0);
  295.   }
  296.  
  297. out:
  298.  
  299.   succeed;
  300. }
  301.  
  302. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  303. This function  implements  $c_current_predicate/2.   current_predicate/2
  304. itself  is  written  in  Prolog, based on this function.  Having dynamic
  305. linking from super modules and dynamic loading from the  libraries,  the
  306. definition  of current predicate has become a difficult issue.  Normally
  307. it is used for meta-programming and program analysis.  I think it should
  308. succeed  for  each  predicate  that  can   be   called.    The   current
  309. implementation  is VERY slow due to all Prolog overhead.  This should be
  310. reconsidered and probably a large part of this function should be  moved
  311. to C.
  312. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  313.  
  314. word
  315. pl_current_predicate(term_t name, term_t spec, word h)
  316. { atom_t n;
  317.   functor_t f;
  318.   Module m = (Module) NULL;
  319.   Procedure proc;
  320.   Symbol symb;
  321.   term_t functor = PL_new_term_ref();
  322.  
  323.   if ( ForeignControl(h) == FRG_CUTTED )
  324.     succeed;
  325.  
  326.   if ( !PL_strip_module(spec, &m, functor) )
  327.     fail;
  328.  
  329.   if ( !PL_get_atom(name, &n) )
  330.   { if ( PL_is_variable(name) )
  331.       n = NULL_ATOM;
  332.     else
  333.       fail;
  334.   }
  335.   if ( !PL_get_functor(functor, &f) )
  336.   { if ( PL_is_variable(functor) )
  337.       f = 0;
  338.     else
  339.       fail;
  340.   }
  341.  
  342.   if ( ForeignControl(h) == FRG_FIRST_CALL)
  343.   { if ( f ) 
  344.     { if ( (proc = isCurrentProcedure(f, m)) )
  345.     return PL_unify_atom(name, nameFunctor(f));
  346.       fail;
  347.     }
  348.     symb = firstHTable(m->procedures);
  349.   } else
  350.     symb = ForeignContextPtr(h);
  351.  
  352.   for(; symb; symb = nextHTable(m->procedures, symb) )
  353.   { FunctorDef fdef;
  354.     
  355.     proc = (Procedure) symb->value;
  356.     fdef = proc->definition->functor;
  357.  
  358.     if ( (n && n != fdef->name) ||
  359.      !PL_unify_atom(name, fdef->name) ||
  360.      !PL_unify_functor(functor, fdef->functor) )
  361.       continue;
  362.  
  363.     if ( (symb = nextHTable(m->procedures, symb)) )
  364.       ForeignRedoPtr(symb);
  365.  
  366.     succeed;
  367.   }
  368.  
  369.   fail;
  370. }
  371.  
  372.  
  373. ClauseRef
  374. newClauseRef(Clause clause)
  375. { ClauseRef cref = allocHeap(sizeof(struct clause_ref));
  376.   
  377.   cref->clause = clause;
  378.   cref->next   = NULL;
  379.  
  380.   return cref;
  381. }
  382.  
  383.  
  384. void
  385. freeClauseRef(ClauseRef cref)
  386. { freeHeap(cref, sizeof(struct clause_ref));
  387. }
  388.  
  389.  
  390. /*  Assert a clause to a procedure. Where askes to assert either at the
  391.     head or at the tail of the clause list.
  392.  
  393.  ** Fri Apr 29 12:44:08 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  394.  
  395. bool
  396. assertProcedure(Procedure proc, Clause clause, int where)
  397. { Definition def = proc->definition;
  398.   ClauseRef cref = newClauseRef(clause);
  399.  
  400.   startCritical;
  401.  
  402.   if ( def->references && (debugstatus.styleCheck & DYNAMIC_STYLE) )
  403.     warning("assert/[1,2]: %s has %d references",
  404.         predicateName(def), def->references);
  405.  
  406.   if ( !def->lastClause )
  407.   { def->definition.clauses = def->lastClause = cref;
  408.   } else if ( where == CL_START )
  409.   { cref->next = def->definition.clauses;
  410.     def->definition.clauses = cref;
  411.   } else
  412.   { ClauseRef last = def->lastClause;
  413.  
  414.     last->next = cref;
  415.     def->lastClause = cref;
  416.   }
  417.  
  418.   def->number_of_clauses++;
  419.  
  420.   if ( def->hash_info )
  421.     addClauseToIndex(def, clause, where);
  422.   else
  423.   { if ( def->number_of_clauses == 25 && true(def, AUTOINDEX) )
  424.       def->indexPattern |= NEED_REINDEX;
  425.   }
  426.  
  427.   endCritical;  
  428.  
  429.   succeed;
  430. }
  431.  
  432. /*  Abolish a procedure.  Referenced  clauses  are   unlinked  and left
  433.     dangling in the dark until the procedure referencing it deletes it.
  434.  
  435.     Since we have a foreign language interface we will allow to  abolish
  436.     foreign  predicates  as  well.  Permission testing should be done by
  437.     the caller.
  438.  
  439.  ** Sun Apr 17 16:18:50 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  440.  
  441. bool
  442. abolishProcedure(Procedure proc, Module module)
  443. { register Definition def = proc->definition;
  444.  
  445.   if ( def->module != module )        /* imported predicate; remove link */
  446.   { Definition ndef         = allocHeap(sizeof(struct definition));
  447.  
  448.     proc->definition         = ndef;
  449.     ndef->functor            = def->functor;
  450.     ndef->module             = module;
  451.     ndef->definition.clauses = NULL;
  452.     ndef->lastClause         = NULL;
  453. #ifdef O_PROFILE
  454.     ndef->profile_ticks      = 0;
  455.     ndef->profile_calls      = 0;
  456.     ndef->profile_redos      = 0;
  457.     ndef->profile_fails      = 0;
  458. #endif /* O_PROFILE */
  459.     resetProcedure(proc);
  460.  
  461.     succeed;
  462.   }
  463.  
  464.   if ( true(def, FOREIGN) )
  465.   { startCritical;
  466.     def->definition.clauses = def->lastClause = NULL;
  467.     resetProcedure(proc);
  468.     endCritical;
  469.  
  470.     succeed;
  471.   }
  472.  
  473.   removeClausesProcedure(proc, 0);
  474.   resetProcedure(proc);
  475.  
  476.   succeed;
  477. }
  478.  
  479.  
  480. static void
  481. removeClausesProcedure(Procedure proc, int sfindex)
  482. { Definition def = proc->definition;
  483.   ClauseRef c;
  484.  
  485.   enterDefinition(def);
  486.  
  487.   for(c = def->definition.clauses; c; c = c->next)
  488.   { Clause cl = c->clause;
  489.  
  490.     if ( (sfindex == 0 || sfindex == cl->source_no) && false(cl, ERASED) )
  491.     { set(cl, ERASED);
  492.       set(def, NEEDSCLAUSEGC);
  493.       def->number_of_clauses--;
  494.     } 
  495.   }
  496.   if ( def->hash_info )
  497.     def->hash_info->alldirty = TRUE;
  498.  
  499.   leaveDefinition(def);
  500. }
  501.  
  502. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  503. Retract a clause from a procedure. When   a clause without references is
  504. retracted it is actually removed from the  heap, otherwise the clause is
  505. unlinked and marked as `erased'. Its next   pointer will not be changed.
  506. to avoid the follow up clause  to  be   destroyed  it  is given an extra
  507. reference.
  508. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  509.  
  510. bool
  511. retractClauseProcedure(Procedure proc, Clause clause)
  512. { Definition def = proc->definition;
  513.  
  514.   if ( true(clause, ERASED) )
  515.     succeed;
  516.  
  517.   if ( def->references )
  518.   { set(clause, ERASED);
  519.     set(def, NEEDSCLAUSEGC);
  520.     if ( def->hash_info )
  521.       markDirtyClauseIndex(def->hash_info, clause);
  522.     def->number_of_clauses--;
  523.     succeed;
  524.   } else
  525.   { ClauseRef prev = NULL;
  526.     ClauseRef c;
  527.     bool rval = FALSE;
  528.  
  529.     startCritical;
  530.  
  531.     if ( def->hash_info )
  532.       delClauseFromIndex(def->hash_info, clause);
  533.  
  534.     for(c = def->definition.clauses; c; prev = c, c = c->next)
  535.     { if ( c->clause == clause )
  536.       { if ( !prev )
  537.     { def->definition.clauses = c->next;
  538.       if ( !c->next )
  539.         def->lastClause = NULL;
  540.     } else
  541.     { prev->next = c->next;
  542.       if ( c->next == NULL)
  543.         def->lastClause = prev;
  544.     }
  545.  
  546.  
  547.       freeClauseRef(c);
  548. #if O_DEBUGGER
  549.     if ( PROCEDURE_event_hook1 &&
  550.          def != PROCEDURE_event_hook1->definition )
  551.       callEventHook(PLEV_ERASED, clause);
  552. #endif
  553.     freeClause(clause);
  554.     def->number_of_clauses--;
  555.  
  556.     rval = TRUE;
  557.     break;
  558.       }
  559.     }
  560.  
  561.     endCritical;
  562.  
  563.     return rval;
  564.   }
  565. }
  566.  
  567.  
  568. void
  569. freeClause(Clause c)
  570. {
  571. #if O_DEBUGGER
  572.   if ( true(c, HAS_BREAKPOINTS) )
  573.     clearBreakPointsClause(c);
  574. #endif
  575.  
  576.   GD->statistics.codes -= c->code_size;
  577.   freeHeap(c->codes, sizeof(code) * c->code_size);
  578.   freeHeap(c, sizeof(struct clause));
  579. }
  580.  
  581.  
  582. void
  583. gcClausesDefinition(Definition def)
  584. { ClauseRef cref = def->definition.clauses, prev = NULL;
  585.   int rehash = 0;
  586. #if O_DEBUG
  587.   int left = 0, removed = 0;
  588. #endif
  589.  
  590.   DEBUG(1, Sdprintf("gcClausesDefinition(%s) --> ", predicateName(def)));
  591.  
  592.   startCritical;
  593.  
  594.   if ( def->hash_info )
  595.   { if ( false(def, NEEDSREHASH) )
  596.       gcClauseIndex(def->hash_info);
  597.     else
  598.     { rehash = def->hash_info->size * 2;
  599.       unallocClauseIndexTable(def->hash_info);
  600.       def->hash_info = NULL;
  601.     }
  602.   }
  603.  
  604.   while( cref )
  605.   { if ( true(cref->clause, ERASED) )
  606.     { ClauseRef c = cref;
  607.       
  608.       cref = cref->next;
  609.       if ( !prev )
  610.       { def->definition.clauses = c->next;
  611.     if ( !c->next )
  612.       def->lastClause = NULL;
  613.       } else
  614.       { prev->next = c->next;
  615.     if ( c->next == NULL)
  616.       def->lastClause = prev;
  617.       }
  618.  
  619.       DEBUG(0, removed++);
  620. #if O_DEBUGGER
  621.       if ( PROCEDURE_event_hook1 && def != PROCEDURE_event_hook1->definition )
  622.     callEventHook(PLEV_ERASED, c->clause);
  623. #endif
  624.       freeClause(c->clause);
  625.       freeClauseRef(c);
  626.     } else
  627.     { prev = cref;
  628.       cref = cref->next;
  629.       DEBUG(0, left++);
  630.     }
  631.   }
  632.  
  633.   DEBUG(1, Sdprintf("removed %d, left %d\n", removed, left));
  634.  
  635.   if ( rehash )
  636.     hashDefinition(def, rehash);
  637.  
  638.   clear(def, NEEDSCLAUSEGC|NEEDSREHASH);
  639.  
  640.   endCritical;
  641. }
  642.  
  643.  
  644. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  645. resetReferences() is called by abort() to clear all predicate references.
  646. Erased clauses will be removed as well.
  647. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  648.  
  649. static void
  650. resetReferencesModule(Module m)
  651. { Definition def;
  652.   Symbol s;
  653.  
  654.   for_table(s, m->procedures)
  655.   { def = ((Procedure) s->value)->definition;
  656. #ifdef O_PROFILE
  657.     clear(def, PROFILE_TICKED);
  658. #endif /* O_PROFILE */
  659.     def->references = 1;
  660.     leaveDefinition(def);
  661.   }
  662. }
  663.  
  664. void
  665. resetReferences(void)
  666. { Symbol s;
  667.  
  668.   for_table(s, GD->tables.modules)
  669.     resetReferencesModule((Module) s->value);
  670. }
  671.  
  672.          /*******************************
  673.          *        CHECKING        *
  674.          *******************************/
  675.  
  676. word
  677. pl_check_definition(term_t spec)
  678. { Procedure proc;
  679.   Definition def;
  680.   int nclauses = 0;
  681.   int nindexable = 0;
  682.  
  683.   ClauseRef cref;
  684.  
  685.   if ( !get_procedure(spec, &proc, 0, GP_FIND) )
  686.     return warning("$check_definition/1: can't find definition");
  687.   def = proc->definition;
  688.  
  689.   if ( true(def, FOREIGN) )
  690.     succeed;
  691.   for(cref = def->definition.clauses; cref; cref = cref->next)
  692.   { Clause clause = cref->clause;
  693.  
  694.     if ( clause->index.varmask != 0 )
  695.       nindexable++;
  696.  
  697.     if ( false(clause, ERASED) )
  698.       nclauses++;
  699.     else
  700.     { if ( false(def, NEEDSCLAUSEGC) )
  701.     warning("%s contains erased clauses and has no NEEDSCLAUSEGC",
  702.         predicateName(def));
  703.     }
  704.   }
  705.  
  706.   if ( def->hash_info )
  707.   { if ( def->hash_info->size != nindexable )
  708.       warning("%s has inconsistent def->hash_info->size",
  709.           predicateName(def));
  710.   }
  711.  
  712.   if ( def->number_of_clauses != nclauses )
  713.     warning("%s has inconsistent number_of_clauses (%d, should be %d)",
  714.         predicateName(def), def->number_of_clauses, nclauses);
  715.  
  716.   succeed;
  717. }
  718.  
  719.  
  720.         /********************************
  721.         *     UNDEFINED PROCEDURES      *
  722.         *********************************/
  723.  
  724. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  725. A dynamic call to `f' in `m' has to be made (via call/1, apply/2 or from
  726. C). This procedure  returns  the  procedure  to  be  run.   If  no  such
  727. procedure  exists  an  undefined  procedure is created and returned.  In
  728. this case interpret() will later call  trapUndefined()  to  generate  an
  729. error message (or link the procedure from the library via autoload).
  730. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  731.  
  732. Procedure
  733. resolveProcedure(functor_t f, Module module)
  734. { Procedure proc;
  735.   Module m;
  736.  
  737.   for( m = module; m; m = m->super )
  738.   { if ( (proc = isCurrentProcedure(f, m)) && isDefinedProcedure(proc) )
  739.       return proc;
  740.   }
  741.  
  742.   return lookupProcedure(f, module);
  743. }
  744.  
  745.  
  746. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  747. autoImport() tries to autoimport f into module `m' and  returns  success
  748. if this is possible.
  749.  
  750. PROBLEM: I'm not entirely  sure  it  is  save  to  deallocated  the  old
  751. definition  structure  in  all  cases.   It  is  not  member of any heap
  752. structure, thus sofar everything  is  alright.   After  a  dynamic  link
  753. interpret()  picks up the new definition pointer, thus this should be ok
  754. as well.  Any other C-code that  does  nasty  things  (non-deterministic
  755. code  perhaps,  calls  indirect via C? (I do recall once conciously have
  756. decided its not save, but can't recall why ...)
  757. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  758.  
  759. Definition
  760. autoImport(functor_t f, Module m)
  761. { Procedure proc;
  762.   Definition def;
  763.                     /* Defined: no problem */
  764.   if ( (proc = isCurrentProcedure(f, m)) && isDefinedProcedure(proc) )
  765.     return proc->definition;
  766.   
  767.   if ( !m->super )            /* No super: can't import */
  768.     return NULL;
  769.  
  770.   if ( !(def = autoImport(f, m->super)) )
  771.     return NULL;
  772.  
  773.   if ( proc == NULL )            /* Create header if not there */
  774.     proc = lookupProcedure(f, m);
  775.                     /* safe? */
  776.   freeHeap(proc->definition, sizeof(struct definition));
  777.   proc->definition = def;
  778.  
  779.   return def;
  780. }
  781.  
  782. static int undefined_nesting;
  783.  
  784. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  785. According to Paulo Moura, predicates defined either dynamic, multifile or
  786. discontiguous should not cause an undefined predicate warning.
  787. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  788.  
  789. Definition
  790. trapUndefined(Definition def)
  791. { int retry_times = 0;
  792.   Definition newdef;
  793.   Module module = def->module;
  794.   FunctorDef functor = def->functor;
  795.  
  796.   retry:
  797.                     /* Auto import */
  798.   if ( (newdef = autoImport(functor->functor, module)) )
  799.     return newdef;
  800.                     /* Pred/Module does not want to trap */
  801.   if ( true(def, DYNAMIC|MULTIFILE|DISCONTIGUOUS) || false(module, UNKNOWN) )
  802.     return def;
  803.  
  804.   DEBUG(5, Sdprintf("trapUndefined(%s)\n", predicateName(def)));
  805.  
  806.                     /* Trap via exception/3 */
  807.   if ( LD->autoload )
  808.   { if ( undefined_nesting > 100 )
  809.     { undefined_nesting = 1;
  810.       sysError("trapUndefined(): undefined: %s", predicateName(def));
  811.  
  812.       return def;
  813.     } else
  814.     { fid_t  cid  = PL_open_foreign_frame();
  815.       term_t argv = PL_new_term_refs(4);
  816.       static predicate_t pred;
  817.       qid_t qid;
  818.       atom_t sfn = source_file_name;    /* needs better solution! */
  819.       int  sln = source_line_no;
  820.       atom_t answer = ATOM_nil;
  821.  
  822.       if ( !pred )
  823.     pred = PL_pred(FUNCTOR_undefinterc4, MODULE_system);
  824.  
  825.       PL_put_atom(    argv+0, def->module->name);
  826.       PL_put_atom(    argv+1, def->functor->name);
  827.       PL_put_integer( argv+2, def->functor->arity);
  828.       PL_put_variable(argv+3);
  829.  
  830.       undefined_nesting++;
  831.       qid = PL_open_query(MODULE_system, PL_Q_NODEBUG, pred, argv);
  832.       if ( PL_next_solution(qid) )
  833.     PL_get_atom(argv+3, &answer);
  834.       PL_close_query(qid);
  835.       undefined_nesting--;
  836.       source_file_name = sfn;
  837.       source_line_no   = sln;
  838.       PL_discard_foreign_frame(cid);
  839.  
  840.       def = lookupProcedure(functor->functor, module)->definition;
  841.  
  842.       if ( answer == ATOM_fail )
  843.     return def;
  844.       else if ( answer == ATOM_retry )
  845.       { if ( retry_times++ )
  846.     { warning("exception handler failed to define predicate %s\n",
  847.           predicateName(def));
  848.       return def;
  849.     }
  850.     goto retry;
  851.       }
  852.     }
  853.   }
  854.                 /* No one wants to intercept */
  855.   warning("Undefined predicate: %s", predicateName(def) );
  856.  
  857.   return def;
  858. }
  859.  
  860.          /*******************************
  861.          *      REQUIRE SUPPORT    *
  862.          *******************************/
  863.  
  864. word
  865. pl_require(term_t pred)
  866. { Procedure proc;
  867.  
  868.   if ( !get_procedure(pred, &proc, 0, GP_RESOLVE) )
  869.     return get_procedure(pred, &proc, 0, GP_DEFINE);
  870.  
  871.   succeed;
  872. }
  873.  
  874.  
  875.         /********************************
  876.         *            RETRACT            *
  877.         *********************************/
  878.  
  879. word
  880. pl_retract(term_t term, word h)
  881. { if ( ForeignControl(h) == FRG_CUTTED )
  882.   { ClauseRef cref = ForeignContextPtr(h);
  883.     leaveDefinition(cref->clause->procedure->definition);
  884.  
  885.     succeed;
  886.   } else
  887.   { Procedure proc;
  888.     Definition def;
  889.     Module m = (Module) NULL;
  890.     ClauseRef cref;
  891.     term_t cl = PL_new_term_ref();
  892.     term_t head = PL_new_term_ref();
  893.     term_t body = PL_new_term_ref();
  894.  
  895.     if ( !PL_strip_module(term, &m, cl) )
  896.       fail;
  897.  
  898.     if ( !get_head_and_body_clause(cl, head, body, NULL) )
  899.       return warning("retract/1: illegal clause");
  900.  
  901.     if ( ForeignControl(h) == FRG_FIRST_CALL )
  902.     { functor_t fd;
  903.  
  904.       if ( !PL_get_functor(head, &fd) )
  905.     return warning("retract/1: illegal head");
  906.       if ( !(proc = isCurrentProcedure(fd, m)) )
  907.     fail;
  908.  
  909.       def = proc->definition;
  910.  
  911.       if ( true(def, FOREIGN) )
  912.     return warning("retract/1: cannot retract from foreign predicate");
  913.       if ( true(def, LOCKED) && false(def, DYNAMIC) )
  914.     return warning("retract/1: Attempt to retract from system predicate");
  915.  
  916.       if ( def->references && (debugstatus.styleCheck & DYNAMIC_STYLE) )
  917.     warning("retract/1: %s has %d references",
  918.         predicateName(def), def->references);
  919.  
  920.       cref = def->definition.clauses;
  921.       enterDefinition(def);            /* reference the predicate */
  922.     } else
  923.     { cref = ForeignContextPtr(h);
  924.       proc = cref->clause->procedure;
  925.       def  = proc->definition;
  926.     }
  927.  
  928.     for(; cref; cref = cref->next)
  929.     { bool det;
  930.       Word argv;
  931.  
  932.       if ( PL_is_compound(head) )
  933.       { argv = valTermRef(head);
  934.     deRef(argv);
  935.     argv = argTermP(*argv, 0);
  936.       } else
  937.     argv = NULL;
  938.  
  939.       if ( !(cref = findClause(cref, argv, def, &det)) )
  940.       { leaveDefinition(def);
  941.     fail;
  942.       }
  943.  
  944.       { fid_t cid = PL_open_foreign_frame();
  945.  
  946.     if ( decompile(cref->clause, cl, 0) )
  947.     { retractClauseProcedure(proc, cref->clause);
  948.       PL_close_foreign_frame(cid);    /* necessary? */
  949.       if ( det == TRUE )
  950.       { leaveDefinition(def);
  951.         succeed;
  952.       }
  953.  
  954.       ForeignRedoPtr(cref->next);
  955.     }
  956.  
  957.     PL_discard_foreign_frame(cid);
  958.       }
  959.  
  960.       continue;
  961.     }
  962.  
  963.     leaveDefinition(def);
  964.     fail;
  965.   }
  966. }
  967.  
  968.  
  969. word
  970. pl_retractall(term_t head)
  971. { term_t thehead = PL_new_term_ref();
  972.   Procedure proc;
  973.   Definition def;
  974.   ClauseRef cref;
  975.  
  976.   if ( !get_procedure(head, &proc, thehead, GP_FINDHERE) )
  977.     succeed;
  978.  
  979.   def = proc->definition;
  980.   if ( true(def, FOREIGN) )
  981.     return warning("retractall/1: cannot retract from a foreign predicate");
  982.   if ( true(def, LOCKED) && false(def, DYNAMIC) )
  983.     return warning("retractall/1: Attempt to retract from a system predicate");
  984.  
  985.   enterDefinition(def);
  986.   for(cref = def->definition.clauses; cref; cref = cref->next)
  987.   { bool det;
  988.     Word argv;
  989.  
  990.     if ( PL_is_compound(thehead) )
  991.     { argv = valTermRef(thehead);
  992.       deRef(argv);
  993.       argv = argTermP(*argv, 0);
  994.     } else
  995.       argv = NULL;
  996.  
  997.     cref = findClause(cref, argv, def, &det);
  998.  
  999.     if ( cref )
  1000.     { fid_t cid = PL_open_foreign_frame();
  1001.     
  1002.       if ( det )
  1003.     leaveDefinition(def);
  1004.  
  1005.       if ( decompileHead(cref->clause, thehead) )
  1006.     retractClauseProcedure(proc, cref->clause);
  1007.  
  1008.       PL_discard_foreign_frame(cid);
  1009.  
  1010.       if ( det )
  1011.     succeed;
  1012.     } else
  1013.       break;
  1014.   }
  1015.   leaveDefinition(def);
  1016.  
  1017.   succeed;
  1018. }
  1019.  
  1020.  
  1021.         /********************************
  1022.         *       PROLOG PREDICATES       *
  1023.         *********************************/
  1024.  
  1025. word
  1026. pl_abolish(term_t atom, term_t arity)
  1027. { functor_t f;
  1028.   Procedure proc;
  1029.   Module m = (Module) NULL;
  1030.   term_t tmp = PL_new_term_ref();
  1031.   atom_t name;
  1032.   int a;
  1033.  
  1034.   if ( !PL_strip_module(atom, &m, tmp) )
  1035.     fail;
  1036.   if ( !PL_get_atom(tmp, &name) || !PL_get_integer(arity, &a) )
  1037.     return warning("abolish/2: instantiation fault");
  1038.  
  1039.   if ( !(f = isCurrentFunctor(name, a)) ||
  1040.        !(proc = isCurrentProcedure(f, m)) )
  1041.     succeed;
  1042.  
  1043.   if ( true(proc->definition, LOCKED) && !SYSTEM_MODE && m == MODULE_system )
  1044.     return PL_error("abolish", 2, NULL, ERR_MODIFY_STATIC_PROC, proc);
  1045.  
  1046.   return abolishProcedure(proc, m);
  1047. }
  1048.  
  1049.  
  1050. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1051. abolish(Name/Arity)
  1052. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1053.  
  1054. word
  1055. pl_abolish1(term_t spec)
  1056. { Procedure proc;
  1057.   functor_t f;
  1058.   Module m = NULL;
  1059.  
  1060.   switch( get_functor(spec, &f, &m, 0, GF_PROCEDURE|GF_EXISTING) )
  1061.   { case FALSE:                /* exception */
  1062.       fail;
  1063.     case -1:                /* no functor */
  1064.       succeed;
  1065.   }
  1066.  
  1067.   if ( !(proc = isCurrentProcedure(f, m)) )
  1068.     succeed;
  1069.  
  1070.   if ( true(proc->definition, LOCKED) && !SYSTEM_MODE && m == MODULE_system )
  1071.     return PL_error("abolish", 1, NULL, ERR_MODIFY_STATIC_PROC, proc);
  1072.  
  1073.   return abolishProcedure(proc, m);
  1074. }
  1075.  
  1076.  
  1077. static unsigned long
  1078. attribute_mask(atom_t key)
  1079. {
  1080. #define TRACE_ANY (TRACE_CALL|TRACE_REDO|TRACE_EXIT|TRACE_FAIL)
  1081.  
  1082.   if (key == ATOM_dynamic)     return DYNAMIC;
  1083.   if (key == ATOM_multifile)     return MULTIFILE;
  1084.   if (key == ATOM_system)     return SYSTEM;
  1085.   if (key == ATOM_locked)     return LOCKED;
  1086.   if (key == ATOM_spy)         return SPY_ME;
  1087.   if (key == ATOM_trace)     return TRACE_ME;
  1088.   if (key == ATOM_trace_call)     return TRACE_CALL;
  1089.   if (key == ATOM_trace_redo)     return TRACE_REDO;
  1090.   if (key == ATOM_trace_exit)     return TRACE_EXIT;
  1091.   if (key == ATOM_trace_fail)     return TRACE_FAIL;
  1092.   if (key == ATOM_trace_any)     return TRACE_ANY;
  1093.   if (key == ATOM_hide_childs)     return HIDE_CHILDS;
  1094.   if (key == ATOM_transparent)     return METAPRED;
  1095.   if (key == ATOM_discontiguous) return DISCONTIGUOUS;
  1096.   if (key == ATOM_volatile)     return VOLATILE;
  1097.  
  1098.   return 0;
  1099. }
  1100.  
  1101.  
  1102. word
  1103. pl_get_predicate_attribute(term_t pred,
  1104.                term_t what, term_t value)
  1105. { Procedure proc;
  1106.   Definition def;
  1107.   functor_t fd;
  1108.   atom_t key;
  1109.   Module module = (Module) NULL;
  1110.   unsigned long att;
  1111.   term_t head = PL_new_term_ref();
  1112.   
  1113.   if ( !PL_strip_module(pred, &module, head) ||
  1114.        !PL_get_functor(head, &fd) ||
  1115.        !(proc = resolveProcedure(fd, module)) )
  1116.     fail;
  1117.  
  1118.   def = proc->definition;
  1119.  
  1120.   if ( !PL_get_atom(what, &key) )
  1121.     return warning("$get_predicate_attribute/3: key should be an atom");
  1122.  
  1123.   if ( key == ATOM_imported )
  1124.   { if ( module == def->module )
  1125.       fail;
  1126.     return PL_unify_atom(value, def->module->name);
  1127.   } else if ( key == ATOM_indexed )
  1128.   { if ( def->indexPattern == 0x0 )
  1129.       fail;
  1130.     return unify_index_pattern(proc, value);
  1131.   } else if ( key == ATOM_exported )
  1132.   { return PL_unify_integer(value, isPublicModule(module, proc));
  1133.   } else if ( key == ATOM_defined )
  1134.   { int d;
  1135.  
  1136.     if ( isDefinedProcedure(proc) )
  1137.       d = 1;
  1138.     else
  1139.       d = 0;
  1140.       
  1141.     return PL_unify_integer(value, d);
  1142.   } else if ( key == ATOM_line_count )
  1143.   { int line;
  1144.  
  1145.     if ( false(def, FOREIGN) &&
  1146.      def->definition.clauses &&
  1147.      (line=def->definition.clauses->clause->line_no) )
  1148.       return PL_unify_integer(value, line);
  1149.     else
  1150.       fail;
  1151.   } else if ( key == ATOM_foreign )
  1152.   { return PL_unify_integer(value, (def->flags & FOREIGN) ? 1 : 0);
  1153.   } else if ( key == ATOM_hashed )
  1154.   { return PL_unify_integer(value, def->hash_info?def->hash_info->buckets:0);
  1155.   } else if ( key == ATOM_references )
  1156.   { return PL_unify_integer(value, def->references);
  1157.   } else if ( key == ATOM_number_of_clauses )
  1158.   { if ( def->flags & FOREIGN )
  1159.       fail;
  1160.  
  1161.     return PL_unify_integer(value, def->number_of_clauses);
  1162.   } else if ( (att = attribute_mask(key)) )
  1163.   { return PL_unify_integer(value, (def->flags & att) ? 1 : 0);
  1164.   } else
  1165.   { return warning("$get_predicate_attribute/3: unknown key: %s",
  1166.            stringAtom(key));
  1167.   }
  1168. }
  1169.   
  1170.  
  1171. word
  1172. pl_set_predicate_attribute(term_t pred,
  1173.                term_t what, term_t value)
  1174. { Procedure proc;
  1175.   Definition def;
  1176.   atom_t key;
  1177.   int val;
  1178.   unsigned long att;
  1179.  
  1180.   if ( !PL_get_atom(what, &key) ||
  1181.        !PL_get_integer(value, &val) || val & ~1 )
  1182.     return warning("$set_predicate_attribute/3: instantiation fault");
  1183.   if ( !(att = attribute_mask(key)) )
  1184.     return warning("$set_predicate_attribute/4: unknown key: %s",
  1185.            stringAtom(key));
  1186.   if ( att & (TRACE_ANY|SPY_ME) )
  1187.   { if ( !get_procedure(pred, &proc, 0, GP_RESOLVE) )
  1188.       fail;
  1189.   } else
  1190.   { if ( !get_procedure(pred, &proc, 0, GP_DEFINE|GP_NAMEARITY) )
  1191.       fail;
  1192.   }
  1193.   def = proc->definition;
  1194.  
  1195.   if ( !val )
  1196.   { clear(def, att);
  1197.   } else
  1198.   { set(def, att);
  1199.     if ( (att == DYNAMIC || att == MULTIFILE) && SYSTEM_MODE )
  1200.     { set(def, SYSTEM|HIDE_CHILDS);
  1201.     }
  1202.   }
  1203.  
  1204.   succeed;
  1205. }
  1206.  
  1207.  
  1208. word
  1209. pl_default_predicate(term_t d1, term_t d2)
  1210. { Procedure p1, p2;
  1211.  
  1212.   if ( get_procedure(d1, &p1, 0, GP_FIND) &&
  1213.        get_procedure(d2, &p2, 0, GP_FIND) )
  1214.   { if ( p1->definition == p2->definition || !isDefinedProcedure(p1) )
  1215.       succeed;
  1216.   }
  1217.  
  1218.   fail;
  1219. }
  1220.  
  1221.  
  1222. void
  1223. reindexDefinition(Definition def)
  1224. { ClauseRef cref;
  1225.   int do_hash = 0;
  1226.  
  1227.   DEBUG(2, if ( def->definition.clauses )
  1228.        { Procedure proc = def->definition.clauses->clause->procedure;
  1229.  
  1230.          Sdprintf("reindexDefinition(%s)\n", procedureName(proc));
  1231.        });
  1232.  
  1233.   if ( true(def, AUTOINDEX) )
  1234.   { int canindex = 0;
  1235.     int cannotindex = 0;
  1236.     
  1237.     for(cref = def->definition.clauses; cref; cref = cref->next)
  1238.     { word key;
  1239.  
  1240.       if ( arg1Key(cref->clause, &key) )
  1241.     canindex++;
  1242.       else
  1243.     cannotindex++;
  1244.     }
  1245.  
  1246.     if ( canindex == 0 )
  1247.     { DEBUG(2, if ( def->definition.clauses )
  1248.            { Procedure proc = def->definition.clauses->clause->procedure;
  1249.  
  1250.          Sdprintf("not indexed: %s\n", procedureName(proc));
  1251.            });
  1252.       def->indexPattern = 0x0;
  1253.     } else
  1254.     { def->indexPattern = 0x1;
  1255.       if ( canindex > 5 && cannotindex <= 2 )
  1256.     do_hash = canindex / 2;
  1257.     }
  1258.   }
  1259.  
  1260.   def->indexPattern &= ~NEED_REINDEX;
  1261.   def->indexCardinality = cardinalityPattern(def->indexPattern);
  1262.   for(cref = def->definition.clauses; cref; cref = cref->next)
  1263.     reindexClause(cref->clause);
  1264.  
  1265.   if ( do_hash )
  1266.   { DEBUG(1,
  1267.       if ( def->definition.clauses )
  1268.       { Procedure proc = def->definition.clauses->clause->procedure;
  1269.  
  1270.         Sdprintf("hash(%s, %d)\n", procedureName(proc), do_hash);
  1271.       });
  1272.     hashDefinition(def, do_hash);
  1273.   }
  1274. }
  1275.  
  1276.  
  1277. word
  1278. pl_index(term_t pred)
  1279. { Procedure proc;
  1280.   term_t head = PL_new_term_ref();
  1281.  
  1282.   if ( get_procedure(pred, &proc, head, GP_CREATE) )
  1283.   { Definition def = proc->definition;
  1284.     int arity = def->functor->arity;
  1285.  
  1286.     if (true(def, FOREIGN))
  1287.       return warning("index/1: cannot index foreign predicate %s", 
  1288.              procedureName(proc));
  1289.  
  1290.     if ( arity > 0 )
  1291.     { unsigned long pattern = 0x0;
  1292.       int n, card = 0;
  1293.       term_t a = PL_new_term_ref();
  1294.  
  1295.       for(n=0; n<arity && n < 31; n++)
  1296.       { int ia;
  1297.  
  1298.     if ( !PL_get_arg(n+1, head, a) ||
  1299.          !PL_get_integer(a, &ia) || (ia & ~1) )
  1300.       return warning("index/1: %s: illegal index specification", 
  1301.              procedureName(proc));
  1302.     if ( ia )
  1303.     { pattern |= 1 << n;
  1304.       if (++card == 4)        /* maximal 4 indexed arguments */
  1305.         break;
  1306.     }
  1307.       }
  1308.       
  1309.       clear(def, AUTOINDEX);
  1310.       if ( (def->indexPattern & ~NEED_REINDEX) == pattern)
  1311.     succeed;
  1312.       def->indexPattern = (pattern | NEED_REINDEX);
  1313.     }
  1314.     succeed;
  1315.   }
  1316.  
  1317.   fail;
  1318. }
  1319.  
  1320.  
  1321. word
  1322. pl_get_clause_attribute(term_t ref, term_t att, term_t value)
  1323. { Clause clause;
  1324.   atom_t a;
  1325.  
  1326.   if ( !PL_get_pointer(ref, (void **)&clause)  ||
  1327.        !inCore(clause) || !isClause(clause) )
  1328.     return warning("$clause_attribute/3: illegal reference");
  1329.   if ( !PL_get_atom(att, &a) )
  1330.     return warning("$clause_attribute/3: instantiation fault");
  1331.  
  1332.   if ( a == ATOM_line_count )
  1333.   { if ( clause->line_no )
  1334.       return PL_unify_integer(value, clause->line_no);
  1335.   } else if ( a == ATOM_file )
  1336.   { SourceFile sf = indexToSourceFile(clause->source_no);
  1337.     
  1338.     if ( sf )
  1339.       return PL_unify_atom(value, sf->name);
  1340.   } else if ( a == ATOM_fact )
  1341.   { return PL_unify_atom(value,
  1342.              true(clause, UNIT_CLAUSE) ? ATOM_true
  1343.                             : ATOM_false);
  1344.   } else if ( a == ATOM_erased )
  1345.   { return PL_unify_atom(value,
  1346.              true(clause, ERASED) ? ATOM_true : ATOM_false);
  1347.   }
  1348.  
  1349.   fail;
  1350. }
  1351.  
  1352.  
  1353.         /********************************
  1354.         *         SOURCE FILE           *
  1355.         *********************************/
  1356.  
  1357. static int source_index = 0;
  1358. static Table sourceTable = NULL;
  1359.  
  1360. SourceFile
  1361. lookupSourceFile(atom_t name)
  1362. { SourceFile file;
  1363.   Symbol s;
  1364.  
  1365.   if ( !sourceTable )
  1366.     sourceTable = newHTable(32);
  1367.  
  1368.   if ( (s=lookupHTable(sourceTable, (void*)name)) )
  1369.     return (SourceFile) s->value;
  1370.  
  1371.   file = (SourceFile) allocHeap(sizeof(struct sourceFile) );
  1372.   file->name = name;
  1373.   file->count = 0;
  1374.   file->time = 0L;
  1375.   file->index = ++source_index;
  1376.   file->system = GD->bootsession;
  1377.   file->procedures = NULL;
  1378.   file->next = NULL;
  1379.  
  1380.   if ( sourceFileTable == NULL )
  1381.   { sourceFileTable = tailSourceFileTable = file;
  1382.   } else
  1383.   { tailSourceFileTable->next = file;
  1384.     tailSourceFileTable = file;
  1385.   }
  1386.  
  1387.   addHTable(sourceTable, (void*)name, file);
  1388.  
  1389.   return file;
  1390. }
  1391.  
  1392.  
  1393. static SourceFile
  1394. indexToSourceFile(int index)
  1395. { SourceFile file;
  1396.  
  1397.   for(file=sourceFileTable; file; file=file->next)
  1398.   { if (file->index == index)
  1399.       return file;
  1400.   }
  1401.  
  1402.   return NULL;
  1403. }
  1404.  
  1405.  
  1406. void
  1407. addProcedureSourceFile(SourceFile sf, Procedure proc)
  1408. { ListCell cell;
  1409.  
  1410.   if ( true(proc->definition, FILE_ASSIGNED) )
  1411.   { for(cell=sf->procedures; cell; cell = cell->next)
  1412.       if ( cell->value == proc )
  1413.     return;
  1414.   }
  1415.  
  1416.   startCritical;
  1417.   cell = allocHeap(sizeof(struct list_cell));
  1418.   cell->value = proc;
  1419.   cell->next = sf->procedures;
  1420.   sf->procedures = cell;
  1421.   set(proc->definition, FILE_ASSIGNED);
  1422.   endCritical;
  1423. }
  1424.  
  1425.  
  1426. word
  1427. pl_make_system_source_files(void)
  1428. { SourceFile file;
  1429.  
  1430.   for(file=sourceFileTable; file; file=file->next)
  1431.     file->system = TRUE;
  1432.  
  1433.   succeed;
  1434. }
  1435.  
  1436.  
  1437. word
  1438. pl_source_file(term_t descr, term_t file, control_t h)
  1439. { Procedure proc;
  1440.   ClauseRef cref;
  1441.   SourceFile sf;
  1442.   atom_t name;
  1443.   ListCell cell;
  1444.   
  1445.  
  1446.   if ( ForeignControl(h) == FRG_FIRST_CALL &&
  1447.        !PL_is_variable(descr) )
  1448.   { if ( !get_procedure(descr, &proc, 0, GP_FIND) ||
  1449.      !proc->definition ||
  1450.      true(proc->definition, FOREIGN) ||
  1451.      !(cref = proc->definition->definition.clauses) ||
  1452.      !(sf = indexToSourceFile(cref->clause->source_no)) )
  1453.       fail;
  1454.  
  1455.     return PL_unify_atom(file, sf->name);
  1456.   }
  1457.  
  1458.   if ( ForeignControl(h) == FRG_CUTTED )
  1459.     succeed;
  1460.  
  1461.   if ( !PL_get_atom(file, &name) ||
  1462.        !(sf = lookupSourceFile(name)) )
  1463.     fail;
  1464.  
  1465.   switch( ForeignControl(h) )
  1466.   { case FRG_FIRST_CALL:
  1467.       cell = sf->procedures;
  1468.       break;
  1469.     case FRG_REDO:
  1470.       cell = ForeignContextPtr(h);
  1471.       break;
  1472.     default:
  1473.       cell = NULL;
  1474.       assert(0);
  1475.   }
  1476.   
  1477.   for( ; cell; cell = cell->next )
  1478.   { Procedure proc = cell->value;
  1479.     Definition def = proc->definition;
  1480.     fid_t cid = PL_open_foreign_frame();
  1481.  
  1482.     if ( unify_definition(descr, def, 0, 0) )
  1483.     { PL_close_foreign_frame(cid);
  1484.  
  1485.       if ( cell->next )
  1486.     ForeignRedoPtr(cell->next);
  1487.       else
  1488.     succeed;
  1489.     }
  1490.  
  1491.     PL_discard_foreign_frame(cid);
  1492.   }
  1493.  
  1494.   fail;
  1495. }
  1496.  
  1497.  
  1498. word
  1499. pl_time_source_file(term_t file, term_t time, control_t h)
  1500. { SourceFile fr;
  1501.  
  1502.   switch( ForeignControl(h) )
  1503.   { case FRG_FIRST_CALL:
  1504.       fr = sourceFileTable;
  1505.       break;
  1506.     case FRG_REDO:
  1507.       fr = ForeignContextPtr(h);
  1508.       break;
  1509.     case FRG_CUTTED:
  1510.     default:
  1511.       succeed;
  1512.   }
  1513.  
  1514.   for(;fr != (SourceFile) NULL; fr = fr->next)
  1515.   { if ( fr->system == TRUE )
  1516.       continue;
  1517.     if ( PL_unify_atom(file, fr->name) &&
  1518.          unifyTime(time, fr->time) )
  1519.     { if (fr->next != (SourceFile) NULL)
  1520.     ForeignRedoPtr(fr->next);
  1521.       else
  1522.     succeed;
  1523.     }
  1524.   }
  1525.  
  1526.   fail;
  1527. }
  1528.  
  1529.  
  1530. void
  1531. startConsult(SourceFile f)
  1532. { if ( f->count++ > 0 )
  1533.   { ListCell cell, next;
  1534.  
  1535.     for(cell = f->procedures; cell; cell = next)
  1536.     { Procedure proc = cell->value;
  1537.  
  1538.       next = cell->next;
  1539.       if ( proc->definition )
  1540.     removeClausesProcedure(proc, true(proc->definition, MULTIFILE)
  1541.                         ? f->index : 0);
  1542.       freeHeap(cell, sizeof(struct list_cell));
  1543.     }
  1544.     f->procedures = NULL;
  1545.   }
  1546.  
  1547.   f->current_procedure = NULL;
  1548. }
  1549.  
  1550.  
  1551. word
  1552. pl_start_consult(term_t file)
  1553. { atom_t name;
  1554.  
  1555.   if ( PL_get_atom(file, &name) )
  1556.   { SourceFile f = lookupSourceFile(name);
  1557.  
  1558.     f->time = LastModifiedFile(stringAtom(name));
  1559.     startConsult(f);
  1560.     succeed;
  1561.   }
  1562.  
  1563.   fail;
  1564. }
  1565.  
  1566.          /*******************************
  1567.          *       DEBUGGER SUPPORT    *
  1568.          *******************************/
  1569.  
  1570. word
  1571. pl_clause_from_source(term_t file, term_t line, term_t clause)
  1572. { atom_t name;
  1573.   SourceFile f;
  1574.   int ln;
  1575.   ListCell cell;
  1576.   Clause c = NULL;
  1577.  
  1578.   if ( !PL_get_atom(file, &name) ||
  1579.        !(f = lookupSourceFile(name)) ||
  1580.        !PL_get_integer(line, &ln) )
  1581.     return warning("clause_from_source/3: instantiation fault");
  1582.   
  1583.  
  1584.   for(cell = f->procedures; cell; cell = cell->next)
  1585.   { Procedure proc = cell->value;
  1586.     Definition def = proc->definition;
  1587.  
  1588.     if ( def && false(def, FOREIGN) )
  1589.     { ClauseRef cref = def->definition.clauses;
  1590.  
  1591.       for( ; cref; cref = cref->next )
  1592.       { Clause cl = cref->clause;
  1593.  
  1594.     if ( cl->source_no == f->index )
  1595.     { if ( ln >= cl->line_no )
  1596.       { if ( !c || c->line_no < cl->line_no )
  1597.           c = cl;
  1598.       }
  1599.     }
  1600.       }
  1601.     }
  1602.   }
  1603.  
  1604.   if ( c )
  1605.     return PL_unify_pointer(clause, c);
  1606.   
  1607.   fail;
  1608. }
  1609.